home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Modules
/
extras0.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-10-07
|
7KB
|
276 lines
;; Eulisp Module
;; Author: pab
;; File: extras0.em
;; Date: Fri Jan 10 04:17:12 1992
;;
;; Project:
;; Description:
;;
(defmodule extras0
(ccc lists list-operators others arith calls macros0 tables
(except (null) class-names)
classes
symbols
formatted-io
generics
vectors
strings
) ()
(defun not (widget) (null widget))
(export not)
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
(export caar cadr cdar cddr)
(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))
(export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
(defun caaaar (x) (car (car (car (car x)))) )
(defun caaadr (x) (car (car (car (cdr x)))) )
(defun caadar (x) (car (car (cdr (car x)))) )
(defun caaddr (x) (car (car (cdr (cdr x)))) )
(defun cadaar (x) (car (cdr (car (car x)))) )
(defun cadadr (x) (car (cdr (car (cdr x)))) )
(defun caddar (x) (car (cdr (cdr (car x)))) )
(defun cadddr (x) (car (cdr (cdr (cdr x)))) )
(defun cdaaar (x) (cdr (car (car (car x)))) )
(defun cdaadr (x) (cdr (car (car (cdr x)))) )
(defun cdadar (x) (cdr (car (cdr (car x)))) )
(defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
(defun cddaar (x) (cdr (cdr (car (car x)))) )
(defun cddadr (x) (cdr (cdr (car (cdr x)))) )
(defun cdddar (x) (cdr (cdr (cdr (car x)))) )
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
(export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
(defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
(export eqcar)
(defun mkquote (x) (list 'quote x))
(export mkquote)
(defun assq (a l)
(cond
((null l) nil)
((eq a (caar l)) (car l))
(t (assq a (cdr l)))) )
(export assq)
(defun list-ref (l n)
(if (equal n 0) (car l)
(list-ref (cdr l) (\- n 1))))
(export list-ref)
(defun \@list-ref-update\@ (l n obj)
(if (equal n 0) ((setter car) l obj)
(\@list-ref-update\@ (cdr l) (- n 1) obj)))
(defun reverse (l)
(reverse-aux l nil))
(defun reverse-aux (l so-far)
(if l (reverse-aux (cdr l)
(cons (car l) so-far))
so-far))
;; (defun reverse (l)
;; (labels ((rev1 (l n)
;; (if (null l) n
;; (rev1 (cdr l) (cons (car l) n)))))
;; (rev1 l nil)))
(export reverse)
(defun subst (a b c)
(cond
((equal c b) a)
((atom c) c)
(t
((lambda (carc cdrc)
(cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
(t (cons carc cdrc))))
(subst a b (car c))
(subst a b (cdr c))))))
(export subst)
(defun delete (a b comp)
(cond
((null b) nil)
((comp a (car b)) (cdr b))
(t ((lambda (del)
(cond ((eq del (cdr b)) b)
(t (cons (car b) del))))
(delete a (cdr b) comp)))))
(export delete)
(defun deleteq (a b)
(cond
((null b) nil)
((eq a (car b)) (cdr b))
(t ((lambda (del)
(cond ((eq del (cdr b)) b)
(t (cons (car b) del))))
(deleteq a (cdr b))))))
(export deleteq)
;; Control Extentions - Exit Extentions
(defmacro block forms (cons 'let/cc forms))
(defmacro return-from (name . forms)
(list name (cons 'progn forms)))
(export block return-from)
(defmacro catch (tag . body)
`(let/cc \@
(dynamic-let ((,tag \@)) ,@body)))
(defmacro throw (tag . forms)
`((dynamic ,tag) (progn ,@forms)))
(export catch throw)
(defmacro prog1 forms
`((lambda (@prog1-handle@)
,@(cdr forms)
@prog1-handle@) ,(car forms)))
(export prog1)
;;
;; Missing bits...
;;
(defun negativep (i) (binary-lt i 0))
(export negativep)
(defun list-copy-aux (l new)
(if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
new))
(defun list-copy (l) (list-copy-aux l nil))
(export list-copy)
;
;; Multiple Values.
;;
;; An el-cheapo pseudo implementation.
;
(defmacro values forms
(if (null (cdr forms)) forms
`(list ,@forms)))
(defun call/mv (f values) (apply f values))
(defmacro let/mv (vars form . body)
`(call/mv (lambda ,vars ,@body) ,form))
(export values call/mv let/mv)
;; Conversion
;; According to the standard (nearly)
(defconstant *convert-tab* (make-table eq))
(defun converter (class)
(let ((xx (table-ref *convert-tab* class)))
(if (not (null xx))
xx
(let ((new-gen (make-converter-generic class)))
((setter converter) class new-gen)
new-gen))))
(defun make-converter-generic (class)
(make-instance generic-function
'name (make-symbol (format nil "~a-converter" (class-name class)))
'lambda-list '(a)
'method-class method))
((setter setter) converter
(lambda (class fn)
((setter table-ref) *convert-tab* class fn)))
(defun convert (x class)
((converter class) x))
(export converter convert)
;; shove in the defined methods...
;; Really so trivial that we could use lisp functions...
(add-method (converter vector)
(make-instance method
'signature (list pair)
'function generic_generic_convert\,Cons\,Vector))
(add-method (converter vector)
(make-instance method
'signature (list (class-of nil))
'function (lambda (a b c)
(make-vector 0))))
(add-method (converter pair)
(make-instance method
'signature (list vector)
'function generic_generic_convert\,Vector\,Cons))
(add-method (converter string)
(make-instance method
'signature (list object)
'function (lambda (h1 h2 obj)
(format nil "~a" obj))))
;; Also need to add:
;; (allsorts) number from string
;; char<-->int
;; string->pair
(defconstant length (make-instance generic-function
'name 'length
'lambda-list '(l)
'method-class method))
(add-method length (make-instance method
'signature (list pair)
'function list-length))
(add-method length (make-instance method
'signature (list vector)
'function vector-length))
;; commented out 'cos there ain't one.
(add-method length (make-instance method
'signature (list string)
'function string-length))
(export length)
)